Code and Notes (Week 8 Thursday (video released later))

{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module PracWk7TakeTwo where
import Control.Monad.State
import Test.QuickCheck

-- Not tail recursive
myReverse :: [a] -> [a]
myReverse [] = []
myReverse (x:xs) = myReverse xs ++ [x]

-- Tail recursive
myReverse' :: [a] -> [a]
myReverse' xs = myReverseAux xs [] where
  myReverseAux [] ys = ys
  myReverseAux (x:xs) ys = myReverseAux xs (x:ys)

{-
myModify :: (s -> s) -> State s ()
myModify f = do
  s <- get
  put (f s)

-- state monaddy version of tail recursion
myReverse'' :: [a] -> [a]
myReverse'' xs = evalState (myReverseAux xs) [] where
  myReverseAux :: [a] -> State [a] [a]
  myReverseAux []     = get -- return the state
  myReverseAux (x:xs) =
    do
      modify (x:)
      myReverseAux xs
-}


-- Monads done differently

class AltMonad m where
  returnA :: a -> m a
  joinA   :: m (m a) -> m a
  fmapA   :: (a -> b) -> m a -> m b

{-
instance AltMonad Maybe where
  -- returnA :: a -> Maybe a
  returnA = Just
  -- joinA :: Maybe(Maybe a) -> Maybe a
  joinA Nothing  = Nothing
  joinA (Just ma) = ma
  -- fmapA :: (a -> b) -> Maybe a -> Maybe b
  fmapA f Nothing = Nothing
  fmapA f (Just a) = Just (f a)

instance AltMonad [] where
  -- returnA :: a -> [a]
  returnA a = [a]
  -- joinA :: [[a]] -> [a]
  joinA   = concat
  -- fmapA :: (a -> b) -> [a] -> [b]
  fmapA   = map

instance Monad m => AltMonad m where
  returnA = return
  joinA mma = mma >>= id
  -- joinA mma = do
  --   ma <- mma
  --   x <- ma
  --   return x
  fmapA   = fmap


instance AltMonad m => Functor m where
  fmap = fmapA

instance AltMonad m => Applicative m where
  pure = returnA
  fm <*> xm = joinA $ fmapA (\x -> fmapA ($ x) fm) xm

instance AltMonad m => Monad m  where
  return = pure
  ma >>= f = joinA $ fmapA f ma

-}



-- zip lists etc

newtype MyZipList a = MyZipList [a] deriving (Eq,Show)

unZipList :: MyZipList a -> [a]
unZipList (MyZipList xs) = xs

instance Functor MyZipList where
  fmap f (MyZipList xs) = MyZipList $ fmap f xs

instance Applicative MyZipList where
  pure = MyZipList . repeat
  MyZipList fs <*> MyZipList as
    = MyZipList $ zipWith ($) fs as





-- streams

data Stream a = SCons a (Stream a)
  deriving Show

streamRepeat :: a -> Stream a
streamRepeat a = SCons a (streamRepeat a)

instance Functor Stream where
  fmap f (SCons x xs) = SCons (f x) (fmap f xs)

{- This function returns the n:th element of a stream,
   or the 0:th if n is negative. It will come
   in handy later I promise!
 -}
nth :: Stream a -> Integer -> a
nth (SCons x xs) n
  | n <= 0    = x
  | otherwise = nth xs (n-1)

{- nats is the stream of all natural numbers:

     SCons 0 (Scons 1 (Scons 2 ...))

   It should obey this property:

     n >= 0   ==>  nth nats n = n
 -}
nats :: Stream Integer
nats = SCons 0 (succ <$> nats)


instance Applicative Stream where
  pure a = SCons a (pure a)
  SCons f fs <*> SCons a as = SCons (f a) (fs <*> as)

instance Arbitrary a => Arbitrary(Stream a) where
  arbitrary = SCons <$> arbitrary <*> arbitrary

prefix :: Integer -> Stream a -> [a]
prefix n (SCons a as) | n<1 = []
                      | otherwise = a:prefix (n-1) as

streamLeftIdentityProp :: Eq a => Integer -> Stream a -> Bool
streamLeftIdentityProp n as
  = prefix n (streamRepeat id <*> as) == prefix n as

sHead :: Stream a -> a
sHead (SCons a _) = a


sKillOne :: (a -> Stream b) -> a -> Stream b
sKillOne f a = case f a of SCons _ as -> as

-- stream zip monad:
instance Monad Stream where
  return = pure
  -- (SCons a _) >>= f = f a -- first option
  -- (SCons a as) >>= f = SCons (sHead $ f a) (as >>= f) -- second option
  (SCons a as) >>= f = SCons (sHead $ f a) (as >>= sKillOne f)


{-
STREAM BIND OPTIONS

  as >>= f

  f :: a -> Stream b

as = a1 a2 a3 a4 ...

f(a1) = a1f1 a1f2 a1f2 a1f4 ..  -- this is a Stream b!

FIRST OPTION FOR BIND:
as >>= f    =     a1f1 a1f2 a1f3 a1f4 ...


RIGHT IDENTITY (broken)
  as >>= return = a1 a1 a1 a1 ... /= a1 a2 a3 a4 ...



SECOND OPTION FOR BIND:
as >>= f    =     a1f1 a2f1 a3f1 a4f1 ...

LEFT IDENTITY (broken)
return a = a a a a a a a a a
return a >>= f = af1 af1 af1 af1 ... /= f a
f a = af1 af2 af3 af4 ...


THIRD OPTION
as >>= f    =     a1f1 a2f2 a3f3 a4f4 ...

LEFT IDENTITY (held)
return a >>= f = f a

RIGHT IDENTITY (held)
as >>= return = a1 a2 a3 a4 = as

-}


zKillOne :: (a -> MyZipList b) -> a -> MyZipList b
zKillOne f a = case f a of 
  MyZipList [] -> MyZipList []
  MyZipList (b:bs) -> MyZipList bs

-- trying the same monad for MyZipList
-- THIS IS AN ILLEGAL MONAD DEFINITION
instance Monad MyZipList where
  return = pure
  MyZipList [] >>= f = MyZipList []
  MyZipList (a:as) >>= f = MyZipList $
    case f a of
      MyZipList [] -> []
      MyZipList (b:bs) -> (b : unZipList (MyZipList as >>= zKillOne f))


-- here is an example of how associativity breaks
m = MyZipList [0,1]

f 1 = MyZipList [1,0]
f _ = MyZipList [0]

g (1) = MyZipList []
g _ = MyZipList [0,0]



-- johannes's code below:
-- (throw it into a new file to test it)
{-
module ZipList where

import Test.QuickCheck
import Test.QuickCheck.Function

data MyZipList a = MyZipList [a] deriving (Eq,Show)

unZipList(MyZipList xs) = xs

instance Functor MyZipList where
  fmap f (MyZipList xs) = MyZipList $ fmap f xs

instance Applicative MyZipList where
  pure = MyZipList . repeat
  MyZipList fs <*> MyZipList xs = MyZipList $ uncurry ($) <$> zip fs xs

instance Monad MyZipList where
  return = pure
  MyZipList m >>= k = MyZipList $
    map (uncurry . flip $ (!!)) ks where
    ks = takeWhile good . zip [0..] $ map (unZipList . k) m
    good (n,[]) = False    
    good (0,xs) = True
    good (n,x:xs) = good (n-1,xs)

instance Arbitrary a => Arbitrary(MyZipList a) where
  arbitrary = MyZipList <$> arbitrary
  shrink = map MyZipList . shrink . unZipList

prop_law1 :: MyZipList Int -> Bool
prop_law1 zs =
  (zs >>= return) == zs

prop_law2 :: Int -> MyZipList Int -> Bool
prop_law2 z k =
  (return z >>= const k) == k

prop_law3 :: MyZipList Int -> (Fun Int (MyZipList Int)) -> (Fun Int (MyZipList Int))-> Bool
prop_law3 m (Fun _ k1) (Fun _ k2) =
  ((m >>= k1) >>= k2) ==
  (m >>= (\x -> k1 x >>= k2))

-- quickCheck prop_law3 found this:

m = MyZipList [0,1]

f 1 = MyZipList [-1,0]
f _ = MyZipList [0]

g (-1) = MyZipList []
g _ = MyZipList [0,0]
-}